home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / seqlib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  25.1 KB  |  720 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;   seqlib.lsp
  21. ;;;;
  22. ;;;;                           sequence routines
  23.  
  24.  
  25. (in-package 'lisp)
  26.  
  27.  
  28. (export '(reduce fill replace
  29.           remove remove-if remove-if-not
  30.           delete delete-if delete-if-not
  31.           count count-if count-if-not
  32.           substitute substitute-if substitute-if-not
  33.           nsubstitute nsubstitute-if nsubstitute-if-not
  34.           find find-if find-if-not
  35.           position position-if position-if-not
  36.           remove-duplicates delete-duplicates
  37.           mismatch search
  38.           sort stable-sort merge))
  39.  
  40.  
  41. (in-package 'system)
  42.  
  43.  
  44. (proclaim '(optimize (safety 2) (space 3)))
  45.  
  46.  
  47. (proclaim '(function seqtype (t) t))
  48. (defun seqtype (sequence)
  49.   (cond ((listp sequence) 'list)
  50.         ((stringp sequence) 'string)
  51.         ((bit-vector-p sequence) 'bit-vector)
  52.         ((vectorp sequence) (list 'array (array-element-type sequence)))
  53.         (t (error "~S is not a sequence." sequence))))
  54.  
  55. (proclaim '(function call-test (t t t t) t))
  56. (defun call-test (test test-not item keyx)
  57.   (cond (test (funcall test item keyx))
  58.         (test-not (not (funcall test-not item keyx)))
  59.         (t (eql item keyx))))
  60.  
  61.  
  62. (proclaim '(function check-seq-start-end (t t) t))
  63. (defun check-seq-start-end (start end)
  64.   (unless (and (si:fixnump start) (si:fixnump end))
  65.           (error "Fixnum expected."))
  66.   (when (> (the fixnum start) (the fixnum end))
  67.         (error "START is greater than END.")))
  68.  
  69. (proclaim '(function test-error() t))
  70. (defun test-error()
  71.   (error "both test and test not supplied"))
  72.  
  73. (defun bad-seq-limit (x &optional y)
  74.   (error "bad sequence limit ~a" (if y (list x y) x)))
  75.  
  76.  
  77. (eval-when (compile eval)
  78. (proclaim '(function the-start (t) fixnum))
  79. (proclaim '(function the-end (t t) fixnum))
  80. (defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y))))
  81. (defmacro f- (x y) `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
  82.  
  83. (defmacro with-start-end ( start end seq &body body)
  84.   `(let ((,start (if ,start (the-start ,start) 0)))
  85.      (declare (fixnum ,start))
  86.      (let ((,end (the-end ,end ,seq))) 
  87.        (declare (fixnum ,end))
  88.        (or (<= ,start ,end) (bad-seq-limit  ,start ,end))
  89.        ,@ body)))
  90. )
  91.  
  92. (defun the-end (x y)
  93.   (cond ((fixnump x)
  94.      (or (<= (the fixnum x) (the fixnum (length y)))
  95.          (bad-seq-limit x))
  96.      x)
  97.     ((null x)
  98.      (length y))
  99.     (t (bad-seq-limit x))))
  100.     
  101. (defun the-start (x)
  102.   (cond ((fixnump x)
  103.      (or (>= (the fixnum x) 0)
  104.          (bad-seq-limit x))
  105.      (the fixnum x))
  106.     ((null x) 0)
  107.     (t (bad-seq-limit x))))
  108.   
  109.  
  110.  
  111. (defun reduce (function sequence
  112.                &key from-end
  113.                     start 
  114.                     end
  115.                     (initial-value nil ivsp))
  116.   (with-start-end  start end sequence
  117.      (cond ((not from-end)
  118.            (when (null ivsp)
  119.                  (when (>= start end)
  120.                        (return-from reduce (funcall function)))
  121.                  (setq initial-value (elt sequence start))
  122.                  (setf start (f+ 1 start))
  123.          )
  124.            (do ((x initial-value
  125.                    (funcall function x (prog1 (elt sequence start)
  126.                           (setf start (f+ 1 start))
  127.                           ))))
  128.                ((>= start end) x)))
  129.           (t
  130.            (when (null ivsp)
  131.                  (when (>= start end)
  132.                        (return-from reduce (funcall function)))
  133.                  (setf end (f+ end -1))
  134.                  (setq initial-value (elt sequence end)))
  135.            (do ((x initial-value (funcall function (elt sequence end) x)))
  136.                ((>= start end) x)
  137.            (setf end (f+ -1 end)))))))
  138.  
  139.  
  140. (defun fill (sequence item
  141.               &key start end )
  142.   (with-start-end start end sequence
  143.           (do ((i start (f+ 1 i)))
  144.               ((>= i end) sequence)
  145.              (declare (fixnum i))
  146.              (setf (elt sequence i) item))))
  147.  
  148.  
  149. (defun replace (sequence1 sequence2
  150.             &key start1  end1
  151.              start2 end2 )
  152.   (with-start-end start1 end1 sequence1
  153.      (with-start-end start2 end2 sequence2          
  154.     (if (and (eq sequence1 sequence2)
  155.              (> start1 start2))
  156.         (do* ((i 0 (f+ 1 i))
  157.               (l (if (<  (f- end1 start1)
  158.                          (f- end2 start2))
  159.                       (f- end1 start1)
  160.                       (f- end2 start2)))
  161.               (s1 (f+ start1  (f+ -1 l)) (f+ -1 s1))
  162.               (s2 (f+ start2  (f+ -1 l)) (f+ -1 s2)))
  163.             ((>= i l) sequence1)
  164.           (declare (fixnum i l s1 s2))
  165.           (setf (elt sequence1 s1) (elt sequence2 s2)))
  166.         (do ((i 0 (f+ 1 i))
  167.              (l (if (<  (f- end1 start1)
  168.                         (f- end2 start2))
  169.                     (f- end1 start1)
  170.                     (f- end2 start2)))
  171.              (s1 start1 (f+ 1 s1))
  172.              (s2 start2 (f+ 1 s2)))
  173.             ((>= i l) sequence1)
  174.           (declare (fixnum i l s1 s2))
  175.           (setf (elt sequence1 s1) (elt sequence2 s2)))))))
  176.  
  177.  
  178. ;;; DEFSEQ macro.
  179. ;;; Usage:
  180. ;;;
  181. ;;;    (DEFSEQ function-name argument-list countp everywherep body)
  182. ;;;
  183. ;;; The arguments ITEM and SEQUENCE (PREDICATE and SEQUENCE)
  184. ;;;  and the keyword arguments are automatically supplied.
  185. ;;; If the function has the :COUNT argument, set COUNTP T.
  186.  
  187. (eval-when (eval compile)
  188. (defmacro defseq
  189.           (f args countp everywherep body
  190.            &aux (*macroexpand-hook* 'funcall))
  191.   (setq *body* body)
  192.   (list 'progn
  193.         (let* ((from-end nil)
  194.                (iterate-i '(i start (f+ 1 i)))
  195.                (iterate-i-from-end '(i (f+ -1  end) (f+ -1 i)))
  196.                (endp-i '(>= i end))
  197.                (endp-i-from-end '(< i start))
  198.                (iterate-i-everywhere '(i 0 (f+ 1 i)))
  199.                (iterate-i-everywhere-from-end '(i (f+ -1  l) (f+ -1  i)))
  200.                (endp-i-everywhere '(>= i l))
  201.                (endp-i-everywhere-from-end '(< i 0))
  202.                (i-in-range '(and (<= start i) (< i end)))
  203.                (x '(elt sequence i))
  204.                (keyx `(funcall key ,x))
  205.                (satisfies-the-test `(call-test test test-not item ,keyx))
  206.                (number-satisfied
  207.                 `(n (internal-count item sequence
  208.                                     :from-end from-end
  209.                                     :test test :test-not test-not
  210.                                     :start start :end end
  211.                                     ,@(if countp '(:count count))
  212.                                     :key key)))
  213.                (within-count '(< k count))
  214.                (kount-0 '(k 0))
  215.                (kount-up '(setq k (f+ 1  k))))
  216.            `(defun ,f (,@args item sequence
  217.                        &key from-end test test-not
  218.                             start end
  219.                             ,@(if countp '(count))
  220.                             (key #'identity)
  221.                        ,@(if everywherep
  222.                              (list '&aux '(l (length sequence)))
  223.                              nil))
  224.           ,@(if everywherep '((declare (fixnum l))))
  225.        (with-start-end start end sequence
  226.       (let ,@(if countp
  227.              '(((count (if (null count)
  228.                    most-positive-fixnum count)))))           
  229.               ,@(if countp '((declare (fixnum count))))
  230.               nil
  231.           (and test test-not (test-error))
  232.                 (if (not from-end)
  233.                     ,(eval-body)
  234.                     ,(progn (setq from-end t
  235.                                   iterate-i iterate-i-from-end
  236.                                   endp-i endp-i-from-end
  237.                                   iterate-i-everywhere
  238.                                   iterate-i-everywhere-from-end
  239.                                   endp-i-everywhere
  240.                                   endp-i-everywhere-from-end)
  241.                             (eval-body)))))))
  242.         `(defun ,(intern (si:string-concatenate (string f) "-IF")
  243.                          (symbol-package f))
  244.                 (,@args predicate sequence
  245.                  &key from-end
  246.                       start end
  247.                       ,@(if countp '(count))
  248.                       (key #'identity))
  249.            (,f ,@args predicate sequence
  250.                :from-end from-end
  251.                :test #'funcall
  252.                :start start :end end
  253.                ,@(if countp '(:count count))
  254.                :key key))
  255.         `(defun ,(intern (si:string-concatenate (string f) "-IF-NOT")
  256.                          (symbol-package f))
  257.                 (,@args predicate sequence
  258.                  &key from-end start end
  259.                       ,@(if countp '(count))
  260.                       (key #'identity))
  261.            (,f ,@args predicate sequence
  262.                :from-end from-end
  263.                :test-not #'funcall
  264.                :start start :end end
  265.                ,@(if countp '(:count count))
  266.                :key key))
  267.         (list 'quote f)))
  268.  
  269. (defmacro eval-body () *body*)
  270. )
  271.  
  272.  
  273. (defseq remove () t nil
  274.   (if (not from-end)
  275.       `(if (listp sequence)
  276.            (let ((l sequence) (l1 nil))
  277.              (do ((i 0 (f+ 1  i)))
  278.                  ((>= i start))
  279.                (declare (fixnum i))
  280.                (push (car l) l1)
  281.                (pop l))
  282.              (do ((i start (f+ 1  i)) (j 0))
  283.                  ((or (>= i end) (>= j count) (endp l))
  284.                   (nreconc l1 l))
  285.                (declare (fixnum i j))
  286.                (cond ((call-test test test-not item (funcall key (car l)))
  287.                       (setf  j (f+ 1  j))
  288.                       (pop l))
  289.                      (t
  290.                       (push (car l) l1)
  291.                       (pop l)))))
  292.            (delete item sequence
  293.                    :from-end from-end
  294.                    :test test :test-not test-not
  295.                    :start start :end end
  296.                    :count count
  297.                    :key key))
  298.       `(delete item sequence
  299.                :from-end from-end
  300.                :test test :test-not test-not
  301.                :start start :end end
  302.                :count count
  303.                :key key)))
  304.  
  305.  
  306. (defseq delete () t t
  307.   (if (not from-end)
  308.       `(if (listp sequence)
  309.            (let* ((l0 (cons nil sequence)) (l l0))
  310.              (do ((i 0 (f+ 1  i)))
  311.                  ((>= i start))
  312.                (declare (fixnum i))
  313.                (pop l))
  314.              (do ((i start (f+ 1  i)) (j 0))
  315.                  ((or (>= i end) (>= j count) (endp (cdr l))) (cdr l0))
  316.                (declare (fixnum i j))
  317.                (cond ((call-test test test-not item (funcall key (cadr l)))
  318.                       (setf  j (f+ 1  j))
  319.                       (rplacd l (cddr l)))
  320.                      (t (setq l (cdr l))))))
  321.            (let (,number-satisfied)
  322.              (declare (fixnum n))
  323.              (when (< n count) (setq count n))
  324.              (do ((newseq
  325.                    (make-sequence (seqtype sequence)
  326.                                   (the fixnum (f- l count))))
  327.                   ,iterate-i-everywhere
  328.                   (j 0)
  329.                   ,kount-0)
  330.                  (,endp-i-everywhere newseq)
  331.                (declare (fixnum i j k))
  332.                (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
  333.                       ,kount-up)
  334.                      (t (setf (elt newseq j) ,x)
  335.                         (setf  j (f+ 1  j)))))))
  336.       `(let (,number-satisfied)
  337.          (declare (fixnum n))
  338.          (when (< n count) (setq count n))
  339.          (do ((newseq
  340.                (make-sequence (seqtype sequence) (the fixnum (f- l count))))
  341.               ,iterate-i-everywhere
  342.               (j (f- (the fixnum (f+ -1  end)) n))
  343.               ,kount-0)
  344.              (,endp-i-everywhere newseq)
  345.            (declare (fixnum i j k))
  346.            (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
  347.                   ,kount-up)
  348.                  (t (setf (elt newseq j) ,x)
  349.                     (setq  j (f+ -1  j))))))))
  350.  
  351.  
  352. (defseq count () nil nil
  353.   `(do (,iterate-i ,kount-0)
  354.        (,endp-i k)
  355.      (declare (fixnum i k))
  356.      (when (and ,satisfies-the-test)
  357.            ,kount-up)))
  358.  
  359.  
  360. (defseq internal-count () t nil
  361.   `(do (,iterate-i ,kount-0)
  362.        (,endp-i k)
  363.      (declare (fixnum i k))
  364.      (when (and ,within-count ,satisfies-the-test)
  365.            ,kount-up)))
  366.  
  367.  
  368. (defseq substitute (newitem) t t
  369.   `(do ((newseq (make-sequence (seqtype sequence) l))
  370.         ,iterate-i-everywhere
  371.         ,kount-0)
  372.        (,endp-i-everywhere newseq)
  373.      (declare (fixnum i k))
  374.      (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
  375.             (setf (elt newseq i) newitem)
  376.             ,kount-up)
  377.            (t (setf (elt newseq i) ,x))))))
  378.  
  379.  
  380. (defseq nsubstitute (newitem) t nil
  381.   `(do (,iterate-i ,kount-0)
  382.        (,endp-i sequence)
  383.      (declare (fixnum i k))
  384.      (when (and ,within-count ,satisfies-the-test)
  385.            (setf ,x newitem)
  386.            ,kount-up)))
  387.  
  388.  
  389. (defseq find () nil nil
  390.   `(do (,iterate-i)
  391.        (,endp-i nil)
  392.      (declare (fixnum i))
  393.      (when ,satisfies-the-test (return ,x))))
  394.  
  395.  
  396. (defseq position () nil nil
  397.   `(do (,iterate-i)
  398.        (,endp-i nil)
  399.      (declare (fixnum i))
  400.      (when ,satisfies-the-test (return i))))
  401.  
  402.  
  403. (defun remove-duplicates (sequence
  404.                           &key from-end
  405.                                test test-not
  406.                    start end
  407.                                (key #'identity))
  408.   (and test test-not (test-error))
  409.   (when (and (listp sequence) (not from-end) (null start)
  410.          (null end))
  411.         (when (endp sequence) (return-from remove-duplicates nil))
  412.         (do ((l sequence (cdr l)) (l1 nil))
  413.             ((endp (cdr l))
  414.              (return-from remove-duplicates (nreconc l1 l)))
  415.           (unless (member1 (car l) (cdr l)
  416.                            :test test :test-not test-not
  417.                            :key key)
  418.                   (setq l1 (cons (car l) l1)))))
  419.   (delete-duplicates sequence
  420.                      :from-end from-end
  421.                      :test test :test-not test-not
  422.                      :start start :end end
  423.                      :key key))
  424.        
  425.  
  426. (defun delete-duplicates (sequence
  427.                           &key from-end
  428.                                test test-not
  429.                                start
  430.                                end 
  431.                                (key #'identity)
  432.                           &aux (l (length sequence)))
  433.   (declare (fixnum l))
  434.   (and test test-not (test-error))
  435.   (when (and (listp sequence) (not from-end) (null start)
  436.          (null end))
  437.         (when (endp sequence) (return-from delete-duplicates nil))
  438.         (do ((l sequence))
  439.             ((endp (cdr l))
  440.              (return-from delete-duplicates sequence))
  441.             (cond ((member1 (car l) (cdr l)
  442.                             :test test :test-not test-not
  443.                             :key key)
  444.                    (rplaca l (cadr l))
  445.                    (rplacd l (cddr l)))
  446.                   (t (setq l (cdr l))))))
  447.   (with-start-end start end sequence
  448.     (if (not from-end)
  449.         (do ((n 0)
  450.              (i start (f+ 1  i)))
  451.             ((>= i end)
  452.              (do ((newseq (make-sequence (seqtype sequence)
  453.                                          (the fixnum (f- l n))))
  454.                   (i 0 (f+ 1  i))
  455.                   (j 0))
  456.                  ((>= i l) newseq)
  457.                (declare (fixnum i j))
  458.                (cond ((and (<= start i)
  459.                            (< i end)
  460.                            (position (funcall key (elt sequence i))
  461.                                      sequence
  462.                                      :test test
  463.                                      :test-not test-not
  464.                                      :start (the fixnum (f+ 1  i))
  465.                                      :end end
  466.                                      :key key)))
  467.                      (t
  468.                       (setf (elt newseq j) (elt sequence i))
  469.                       (setf  j (f+ 1  j))))))
  470.           (declare (fixnum n i))
  471.           (when (position (funcall key (elt sequence i))
  472.                           sequence
  473.                           :test test
  474.                           :test-not test-not
  475.                           :start (the fixnum (f+ 1  i))
  476.                           :end end
  477.                           :key key)
  478.                 (setf  n (f+ 1  n))))
  479.         (do ((n 0)
  480.              (i (f+ -1  end) (f+ -1  i)))
  481.             ((< i start)
  482.              (do ((newseq (make-sequence (seqtype sequence)
  483.                                          (the fixnum (f- l n))))
  484.                   (i (f+ -1  l) (f+ -1  i))
  485.                   (j (f- (the fixnum (f+ -1  l)) n)))
  486.                  ((< i 0) newseq)
  487.                (declare (fixnum i j))
  488.                (cond ((and (<= start i)
  489.                            (< i end)
  490.                            (position (funcall key (elt sequence i))
  491.                                      sequence
  492.                                      :from-end t
  493.                                      :test test
  494.                                      :test-not test-not
  495.                                      :start start
  496.                                      :end i
  497.                                      :key key)))
  498.                      (t
  499.                       (setf (elt newseq j) (elt sequence i))
  500.                       (setq  j (f+ -1  j))))))
  501.           (declare (fixnum n i))
  502.           (when (position (funcall key (elt sequence i))
  503.                           sequence
  504.                           :from-end t
  505.                           :test test
  506.                           :test-not test-not
  507.                           :start start
  508.                           :end i
  509.                           :key key)
  510.                 (setf  n (f+ 1  n)))))))
  511.        
  512.  
  513. (defun mismatch (sequence1 sequence2
  514.          &key from-end test test-not
  515.               (key #'identity)
  516.               start1 start2
  517.               end1 end2)
  518.   (and test test-not (test-error))
  519.   (with-start-end start1 end1 sequence1
  520.    (with-start-end start2 end2 sequence2
  521.     (if (not from-end)
  522.         (do ((i1 start1 (f+ 1  i1))
  523.              (i2 start2  (f+ 1  i2)))
  524.             ((or (>= i1 end1) (>= i2 end2))
  525.              (if (and (>= i1 end1) (>= i2 end2)) nil i1))
  526.           (declare (fixnum i1 i2))
  527.           (unless (call-test test test-not
  528.                              (funcall key (elt sequence1 i1))
  529.                              (funcall key (elt sequence2 i2)))
  530.                   (return i1)))
  531.         (do ((i1 (f+ -1  end1) (f+ -1  i1))
  532.              (i2 (f+ -1  end2)  (f+ -1  i2)))
  533.             ((or (< i1 start1) (< i2 start2))
  534.              (if (and (< i1 start1) (< i2 start2)) nil (f+ 1 i1)))
  535.           (declare (fixnum i1 i2))
  536.           (unless (call-test test test-not
  537.                              (funcall key (elt sequence1 i1))
  538.                              (funcall key (elt sequence2 i2)))
  539.                   (return (f+ 1 i1))))))))
  540.  
  541.  
  542. (defun search (sequence1 sequence2
  543.                &key from-end test test-not 
  544.                     (key #'identity)
  545.             start1 start2
  546.             end1 end2)
  547.   (and test test-not (test-error))
  548.   (with-start-end start1 end1 sequence1
  549.    (with-start-end start2 end2 sequence2  
  550.     (if (not from-end)
  551.         (loop
  552.          (do ((i1 start1 (f+ 1  i1))
  553.               (i2 start2 (f+ 1  i2)))
  554.              ((>= i1 end1) (return-from search start2))
  555.            (declare (fixnum i1 i2))
  556.            (when (>= i2 end2) (return-from search nil))
  557.            (unless (call-test test test-not
  558.                               (funcall key (elt sequence1 i1))
  559.                               (funcall key (elt sequence2 i2)))
  560.                    (return nil)))
  561.          (setf  start2 (f+ 1  start2)))
  562.         (loop
  563.          (do ((i1 (f+ -1  end1) (f+ -1  i1))
  564.               (i2 (f+ -1  end2) (f+ -1  i2)))
  565.              ((< i1 start1) (return-from search (the fixnum (f+ 1  i2))))
  566.            (declare (fixnum i1 i2))
  567.            (when (< i2 start2) (return-from search nil))
  568.            (unless (call-test test test-not
  569.                               (funcall key (elt sequence1 i1))
  570.                               (funcall key (elt sequence2 i2)))
  571.                    (return nil)))
  572.          (setq  end2 (f+ -1  end2)))))))
  573.  
  574.  
  575. (defun sort (sequence predicate &key (key #'identity))
  576.   (if (listp sequence)
  577.       (list-merge-sort sequence predicate key)
  578.       (quick-sort sequence 0 (the fixnum (length sequence)) predicate key)))
  579.  
  580.  
  581. (defun list-merge-sort (l predicate key)
  582.   (labels
  583.    ((sort (l)
  584.       (prog ((i 0) left right l0 l1 key-left key-right)
  585.         (declare (fixnum i))
  586.         (setq i (length l))
  587.         (cond ((< i 2) (return l))
  588.               ((= i 2)
  589.                (setq key-left (funcall key (car l)))
  590.                (setq key-right (funcall key (cadr l)))
  591.                (cond ((funcall predicate key-left key-right) (return l))
  592.                      ((funcall predicate key-right key-left)
  593.                       (return (nreverse l)))
  594.                      (t (return l)))))
  595.         (setq i (floor i 2))
  596.         (do ((j 1 (f+ 1  j)) (l1 l (cdr l1)))
  597.             ((>= j i)
  598.              (setq left l)
  599.              (setq right (cdr l1))
  600.              (rplacd l1 nil))
  601.           (declare (fixnum j)))
  602.         (setq left (sort left))
  603.         (setq right (sort right))
  604.         (cond ((endp left) (return right))
  605.               ((endp right) (return left)))
  606.         (setq l0 (cons nil nil))
  607.         (setq l1 l0)
  608.         (setq key-left (funcall key (car left)))
  609.         (setq key-right (funcall key (car right)))
  610.       loop
  611.         (cond ((funcall predicate key-left key-right) (go left))
  612.               ((funcall predicate key-right key-left) (go right))
  613.               (t (go left)))
  614.       left
  615.         (rplacd l1 left)
  616.         (setq l1 (cdr l1))
  617.         (setq left (cdr left))
  618.         (when (endp left)
  619.               (rplacd l1 right)
  620.               (return (cdr l0)))
  621.         (setq key-left (funcall key (car left)))
  622.         (go loop)
  623.       right
  624.         (rplacd l1 right)
  625.         (setq l1 (cdr l1))
  626.         (setq right (cdr right))
  627.         (when (endp right)
  628.               (rplacd l1 left)
  629.               (return (cdr l0)))
  630.         (setq key-right (funcall key (car right)))
  631.         (go loop))))
  632.    (sort l)))
  633.  
  634.  
  635. #|
  636. (defun list-quick-sort (l predicate key)
  637.   (if (or (endp l) (endp (cdr l)))
  638.       l
  639.       (multiple-value-bind (x y)
  640.           (list-quick-sort-partition (car l) (cdr l) predicate key)
  641.         (nconc (list-quick-sort x predicate key)
  642.                (list (car l))
  643.                (list-quick-sort y predicate key)))))
  644.  
  645. (defun list-quick-sort-partition (k l predicate key)
  646.   (do ((l l (cdr l)) (x nil) (y nil))
  647.       ((endp l) (values (nreverse x) (nreverse y)))
  648.     (if (funcall predicate (funcall key (car l)) (funcall key k))
  649.         (setq x (cons (car l) x))
  650.         (setq y (cons (car l) y)))))
  651. |#
  652.  
  653.  
  654. (proclaim '(function quick-sort (t fixnum fixnum t t) t))
  655.  
  656. (defun quick-sort (seq start end pred key)
  657.        (declare (fixnum start end))
  658.   (if (<= end (the fixnum (f+ 1  start)))
  659.       seq
  660.       (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
  661.             (declare (fixnum j k))
  662.         (block outer-loop
  663.           (loop (loop (setq  k (f+ -1  k))
  664.                       (unless (< j k) (return-from outer-loop))
  665.                       (when (funcall pred (funcall key (elt seq k)) kd)
  666.                             (return)))
  667.                 (loop (setf  j (f+ 1  j))
  668.                       (unless (< j k) (return-from outer-loop))
  669.                       (unless (funcall pred (funcall key (elt seq j)) kd)
  670.                               (return)))
  671.                 (let ((temp (elt seq j)))
  672.                   (setf (elt seq j) (elt seq k)
  673.                         (elt seq k) temp))))
  674.         (setf (elt seq start) (elt seq j)
  675.               (elt seq j) d)
  676.         (quick-sort seq start j pred key)
  677.         (quick-sort seq (f+ 1  j) end pred key))))
  678.  
  679. (defun stable-sort (sequence predicate &key (key #'identity))
  680.   (if (listp sequence)
  681.       (list-merge-sort sequence predicate key)
  682.       (if (or (stringp sequence) (bit-vector-p sequence))
  683.           (sort sequence predicate :key key)
  684.           (coerce (list-merge-sort (coerce sequence 'list)
  685.                                    predicate
  686.                                    key)
  687.                   (seqtype sequence)))))
  688.  
  689.  
  690. (defun merge (result-type sequence1 sequence2 predicate
  691.           &key (key #'identity)
  692.           &aux (l1 (length sequence1)) (l2 (length sequence2)))
  693.   (declare (fixnum l1 l2))
  694.   (do ((newseq (make-sequence result-type (the fixnum (f+ l1 l2))))
  695.        (j 0 (f+ 1  j))
  696.        (i1 0)
  697.        (i2 0))
  698.       ((and (= i1 l1) (= i2 l2)) newseq)
  699.     (declare (fixnum j i1 i2))
  700.     (cond ((and (< i1 l1) (< i2 l2))
  701.        (cond ((funcall predicate
  702.                (funcall key (elt sequence1 i1))
  703.                (funcall key (elt sequence2 i2)))
  704.           (setf (elt newseq j) (elt sequence1 i1))
  705.           (setf  i1 (f+ 1  i1)))
  706.          ((funcall predicate
  707.                (funcall key (elt sequence2 i2))
  708.                (funcall key (elt sequence1 i1)))
  709.           (setf (elt newseq j) (elt sequence2 i2))
  710.           (setf  i2 (f+ 1  i2)))
  711.          (t
  712.           (setf (elt newseq j) (elt sequence1 i1))
  713.           (setf  i1 (f+ 1  i1)))))
  714.           ((< i1 l1)
  715.        (setf (elt newseq j) (elt sequence1 i1))
  716.        (setf  i1 (f+ 1  i1)))
  717.       (t
  718.        (setf (elt newseq j) (elt sequence2 i2))
  719.        (setf  i2 (f+ 1  i2))))))
  720.